perm filename UNITRE.NEW[1,JRA] blob sn#028943 filedate 1973-03-08 generic text, type T, neo UTF8
00002	(DE RESUNITP(P TM L)(PROG (Z)
00004	A(SETQ Z(CDADAR L))
00006	(COND((EQ(CAR Z) P)(GO C)))
00008	B(SETQ L(CDR L))
00010	(COND(L(GO A)))
00012	(RETURN NIL)
00014	C(COND((UNIFY(CDR Z) TM)(RETURN(LIST NIL))))
00016	(GO B)))
00018	
00020	(DE RESUNITN(P TM L)
00022	(PROG (Z)
00024	A(SETQ Z(CADAR L))
00026	(COND((EQ(CAR Z)P)(GO C)))
00028	B(SETQ L(CDR L))
00030	(COND(L(GO A)))
00032	(RETURN NIL)
00034	C(COND((UNIFY(CDR Z)TM)(RETURN(LIST NIL))))
00036	(GO B)))
00038	
00100	
00200	
00300	(DEFPROP UNITRES 
00400	 (LAMBDA(C UP UN)
00500	  (PROG (C1 Z1 U Z RES)
00600		(SETQ C1 C)
00700		(COND ((AND (ALLPOS C) (NULL UN)) (RETURN NIL)) ((AND (ALLNEG C) (NULL UP)) (RETURN NIL)))
00750	(COND((UNIT C)(RETURN(COND((ALLPOS C)(RESUNITP(CAADR C)(CDADR C)UN))
00775			(T(RESUNITN(CADADR C)(CDDADR C)UP)))) ))
00800		(COND ((NULL UN) (SETQ C (NEGL C)) (GO N)))
00900		(SETQ C (CDR C))
01000	   B    (SETQ Z1 (CAR C))
01100		(COND ((NEG Z1) (GO N)))
01200		(SETQ U UN)
01300	   A    (COND ((NOT (EQ (CAR Z1) (CADADR (CAR U)))) (GO A1)))
01400		(SETQ Z (UNI (CDDADR (CAR U)) (CDR Z1) NIL))
01500		(COND ((NULL Z) (GO A1)))
01600		(COND ((NULL Z) (GO A1)) ((UNIT C1) (RETURN (LIST NIL))))
01700		(SETQ RES (CONS (REDUCER C1 C) RES))
01800		(GO A2)
01900	   A1   (SETQ U (CDR U))
02000		(COND (U (GO A)))
02100	   A2   (SETQ C (CDR C))
02200		(COND (C (GO B)) (T (RETURN RES)))
02300	   N    (SETQ Z1 (CDAR C))
02400		(SETQ U UP)
02500	   C    (COND ((NULL U) (RETURN RES)))
02600	   C2   (COND ((NOT (EQ (CAR Z1) (CAADAR U))) (GO C1)))
02700		(SETQ Z (UNI (CDADAR U) (CDR Z1) NIL))
02800		(COND ((NULL Z) (GO C1)) ((UNIT C1) (RETURN (LIST NIL))))
02900		(SETQ RES (CONS (REDUCER C1 C) RES))
03000		(GO C3)
03100	   C1   (SETQ U (CDR U))
03200		(COND (U (GO C2)))
03300	   C3   (SETQ C (CDR C))
03400		(COND (C (GO N)) (T (RETURN RES))))) 
03500	EXPR)